home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / Matts-utils.sea / Matts-utils / sound-fun.lisp / sound-fun.lisp
Encoding:
Text File  |  1992-04-06  |  25.3 KB  |  658 lines  |  [TEXT/CCL2]
  1. ;;;
  2. ;;; sound-fun.Lisp
  3. ;;;
  4.  
  5. #|
  6. ================================================================
  7. Purpose ========================================================
  8. ================================================================
  9.  
  10. Contains code for experimenting with the extended sound manager's square
  11. wave, wave table, and sampled sounds synthesizers. Defines the sound-dialog
  12. dialog subclass that has a sound associated with each of its four buttons.
  13. Also, pressing one of the keys 1-4 will play the corresponding button's
  14. sound.
  15.  
  16. To try the example out: Evaluate this file then evaluate
  17. (make-instance 'sound-dialog) .
  18.  
  19.  
  20. To use a particular synthesizer: Which synth is used is determined in
  21. play-button-snd; the default is the wave table synth. The wave table is
  22. specified in sound-dialog's initialize-instance :after method. If you want
  23. to use the square wave synth change play-button-snd to pass :square-wave? t
  24. to play-note. If you want to use the sampled sound synth uncomment the two
  25. forms in play-button-snd and comment-out the others, and uncomment the two
  26. resource-related forms at this file's top. You will need to substitute for
  27. "ccl:HAT;Resources;emits.rsrc" the name of a suitable file that contains sampled
  28. 'snd 's, and you will need my "resource utils.lisp" file which should be
  29. available where you found this file.
  30.  
  31.  
  32. Background: I wrote this file to test the Sound Manager's performance in
  33. playing sampled sounds to evaluate using it as a drum machine. My first
  34. version simply called SndPlay using the appropriate handle. This was
  35. unacceptable because the response was too slow and the sounds were played
  36. synchronously so we need to stop and restart a sound if it's playing when
  37. its key is hit. This means we must explicitly pass a channel to SndPlay so
  38. we can stop the previous sound and restart it. So I now keep four
  39. SndChannel records in the window which are allocated and deallocated via
  40. #_SndNewChannel and #_SndDisposeChannel. To do asynchronous sounds and to
  41. stop currently-playing sounds I use the SndChannel's userInfo field with
  42. these values (states): *released*, *quietNotReleased*, and *playing*. (See the
  43. constants' definitions for their semantics.) But alas the thing is still
  44. too slow (and it's not MCL's fault!). Yet this file does show how to use
  45. the various synths.
  46.  
  47. Copyright © 1990-92 Matthew Cornell. All Rights Reserved. Send
  48. bugs, comments, questions, and fixes to cornell@cs.umass.edu.
  49.  
  50.  
  51. ================================================================
  52. Status =========================================================
  53. ================================================================
  54. Implemented.
  55.  
  56.  
  57. ================================================================
  58. Change history =================================================
  59. ================================================================
  60. 20-Aug-91 mc    Created.
  61. 21-Aug-91 mc    Changed to using a dialog.
  62. 24-Aug-91 mc    Get "pre-emptive" sound production working. Still unresponsive…
  63.  2-Oct-91 mc    Added functions to use the #$squareWaveSynth. Result: couldn't
  64.          play more than one note at a time. So:
  65.  2-Oct-91 mc    Added functions for #$waveTableSynth.
  66. 18-Oct-91 mc    Added further comments for release.
  67. 14-Mar-92 mc    Put into cl-user package.
  68.  6-Apr-92 mc    Changed names of *released*, *quietNotReleased*, and *playing* .
  69.         Changed $var to #$var to eliminate warnings and errors.
  70.         Changed sample resource file and resource names.
  71.         Changed #\3 in view-key-event-handler to #\5 .
  72.  
  73. |#
  74.  
  75. (in-package "CL-USER")
  76.  
  77. (ccl::require-interface "SOUND")
  78.  
  79.  
  80. #| ;;; Open the resource file that contains the needed sounds.
  81.  
  82. (require "resource-utils" "ccl:UMASS Utils;resource-utils")
  83. (open-resource-file "ccl:HAT;Resources;emits.rsrc")
  84.  
  85. |#
  86.  
  87.  
  88. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  89. ;;;
  90. ;;; Define the constants.
  91. ;;;
  92.  
  93. (defconstant *quietNotReleased* #x0
  94.   "Means the channel is not playing but has NOT been released. Set by the
  95. callback routine.")
  96.  
  97. (defconstant *released* #x1
  98.   "Means the channel is not playing and HAS been released.")
  99.  
  100. (defconstant *playing* #x2
  101.   "Means the channel is currently playing a sound.")
  102.  
  103.  
  104. (defmethod state-number->name ((state-number fixnum))
  105.   "Returns the symbol corresponding to STATE-NUMBER or errors."
  106.   ;;
  107.   (cond ((= state-number *quietNotReleased*)
  108.          '*quietNotReleased*)
  109.         ((= state-number *released*)
  110.          '*released*)
  111.         ((= state-number *playing*)
  112.          '*playing*)
  113.         (t (error "~S is not one of these known states: ~S."
  114.                   state-number (list *released* *quietNotReleased* *playing*)))))
  115.  
  116.  
  117. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  118. ;;;
  119. ;;; Define the callback routine. The following is:
  120. ;;
  121. ;; Copyright © 1990 Northwestern University Institute for the Learning Sciences
  122. ;; All Rights Reserved
  123. ;;
  124. ;; author: Michael S. Engber
  125. ;;
  126. ;;;
  127. ;;; Since the call back routine is called at interrupt time, there are several
  128. ;;; restrictions on it (see Sound Manager chapter of IM) which MACL's defpascal
  129. ;;; mechanism does not obey. So it was written in C. The compiled code is small
  130. ;;; enough that we can just copy its machine code into memory when a sound channel
  131. ;;; is created (avoiding loading CODE resources or external function calls)
  132. ;;;
  133. ;;;     #include <SoundMgr.h>
  134. ;;;
  135. ;;;     pascal void main (SndChannelPtr theChan, SndCommand* theCmd){
  136. ;;;      theChan->userInfo = 0L;
  137. ;;;     }
  138. ;;;
  139. ;;; 
  140.  
  141. (defvar *snd-call-back-mcode* "600E0000434F444501F400000000000041FAFFEE4E714E71600000024E560000206E000C42A8000C4E5E205F4FEF00084ED04D41494E20202020"
  142.   "The machine code (hex) for call back routine.")
  143.  
  144.  
  145. (defvar *snd-call-back-ptr* nil "The pointer to call back routine.")
  146.  
  147.  
  148. (defun stuff-call-back-ptr ()
  149.   "Stuffs machine code for call back routine into memory."
  150.   ;;
  151.   (when *snd-call-back-ptr*
  152.     (dispose-of-call-back-ptr))
  153.   (setf *snd-call-back-ptr* (#_NewPtr (/ (length *snd-call-back-mcode*) 2)))
  154.   (with-pstrs ((p *snd-call-back-mcode*))
  155.     (#_StuffHex *snd-call-back-ptr* p)))
  156.  
  157. (stuff-call-back-ptr)
  158.  
  159.  
  160. (defun dispose-of-call-back-ptr ()
  161.   (when *snd-call-back-ptr*
  162.     (#_DisposPtr *snd-call-back-ptr*)
  163.     (setf *snd-call-back-ptr* nil)))
  164.  
  165. (pushnew #'dispose-of-call-back-ptr *lisp-cleanup-functions*
  166.          :test #'eq :key #'function-name)   ;function-name is a ccl function
  167.  
  168.  
  169. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  170. ;;;
  171. ;;; Define the sound-dialog class and methods.
  172. ;;;
  173. ;;;  The item's text strings are the 'snd ' resource names. The sounds are
  174. ;;;  activated by either pressing the button with the mouse or hitting the
  175. ;;;  appropriate character. The keys are the keypad keys 1, 2, 4, and 5
  176. ;;;  arranged like the buttons are:  #\4   #\5
  177. ;;;
  178. ;;;                                  #\1   #\2
  179. ;;;
  180. ;;; Sound playing protocol: You specify which sound to play by passing to
  181. ;;; my-play-sound the nickname (symbol) of the corresponding button which
  182. ;;; plays that sound.
  183. ;;;
  184.  
  185. (defclass sound-dialog (dialog)
  186.   (;; The following four channel slots hold SndChannel records. The are
  187.    ;; deallocated by window-close.
  188.    (channel1
  189.     :accessor channel1
  190.     :type macptr)
  191.    (channel2
  192.     :accessor channel2
  193.     :type macptr)
  194.    (channel3
  195.     :accessor channel3
  196.     :type macptr)
  197.    (channel4
  198.     :accessor channel4
  199.     :type macptr)
  200.    ;;
  201.    (int-table-length
  202.     :accessor int-table-length :type fixnum
  203.     :documentation "The wave table's length in bytes.")
  204.    (ptr-table-data
  205.     :accessor ptr-table-data :type fixnum
  206.     :documentation "The wave table's data.")
  207.    )
  208.   (:default-initargs
  209.     :WINDOW-TYPE :TOOL :VIEW-POSITION '(:TOP 111)
  210.     :VIEW-SIZE #@(194 59) :VIEW-FONT '("Chicago" 12 :SRCOR :PLAIN)
  211.     :VIEW-SUBVIEWS
  212.     (LIST (MAKE-DIALOG-ITEM 'BUTTON-DIALOG-ITEM
  213.                             #@(4 31)
  214.                             #@(84 16)
  215.                             "Got an IV started"
  216.                             #'(lambda (item)
  217.                                 (play-button-snd (view-container item)
  218.                                              'BOTTOM-LEFT-ITEM))
  219.                             :VIEW-NICK-NAME 'BOTTOM-LEFT-ITEM
  220.                             :DEFAULT-BUTTON NIL)
  221.           (MAKE-DIALOG-ITEM 'BUTTON-DIALOG-ITEM
  222.                             #@(97 31)
  223.                             #@(84 16)
  224.                             "Trouble with the IV"
  225.                             #'(lambda (item)
  226.                                 (play-button-snd (view-container item)
  227.                                              'BOTTOM-RIGHT-ITEM))
  228.                             :VIEW-NICK-NAME 'BOTTOM-RIGHT-ITEM
  229.                             :DEFAULT-BUTTON NIL)
  230.           (MAKE-DIALOG-ITEM 'BUTTON-DIALOG-ITEM
  231.                             #@(4 4)
  232.                             #@(84 16)
  233.                             "Got The Tube In"
  234.                             #'(lambda (item)
  235.                                 (play-button-snd (view-container item)
  236.                                              'TOP-LEFT-ITEM))
  237.                             :VIEW-NICK-NAME 'TOP-LEFT-ITEM
  238.                             :DEFAULT-BUTTON NIL)
  239.           (MAKE-DIALOG-ITEM 'BUTTON-DIALOG-ITEM
  240.                             #@(97 4)
  241.                             #@(84 16)
  242.                             "Trouble with the Tube"
  243.                             #'(lambda (item)
  244.                                 (play-button-snd (view-container item)
  245.                                              'TOP-RIGHT-ITEM))
  246.                             :VIEW-NICK-NAME 'TOP-RIGHT-ITEM
  247.                             :DEFAULT-BUTTON NIL)))
  248.   (:documentation "A class of window that plays sounds when you press the
  249. top row's number keys. The character/sound-alist slot determines which
  250. characters play which sounds."))
  251.  
  252.  
  253. (defmethod initialize-instance :after ((object sound-dialog)
  254.                                      &key)
  255.   "Allocates and initializes the sound channels and the wave table."
  256.   ;;
  257.   ;; Save new SndChannel records in OBJECT's slots and set each channel's
  258.   ;; userInfo field to *released* and each qLength field to #$stdQLength.
  259.   ;;
  260.   (setf (channel1 object) (make-record :SndChannel :qLength #$stdQLength)
  261.         (channel2 object) (make-record :SndChannel :qLength #$stdQLength)
  262.         (channel3 object) (make-record :SndChannel :qLength #$stdQLength)
  263.         (channel4 object) (make-record :SndChannel :qLength #$stdQLength))
  264.   (rset (channel1 object) SndChannel.userInfo *released*)
  265.   (rset (channel2 object) SndChannel.userInfo *released*)
  266.   (rset (channel3 object) SndChannel.userInfo *released*)
  267.   (rset (channel4 object) SndChannel.userInfo *released*)
  268.   ;;
  269.   ;; Allocate the wave table and install triangle wave data.
  270.   ;;
  271.   (setf (int-table-length object) 512
  272.         (ptr-table-data object) (#_NewPtr (int-table-length object)))
  273. #|
  274.   ;; Install a triangle wave:
  275.   (let ((int-slope (/ (- #xFF #x80) (int-table-length object)))
  276.         (int-offset #x80))
  277.     (labels ((int-index->data-value (int-index)
  278.                "Returns the data value for int-index corresponding to a line
  279. from (0, #x80) to (512, #xFF)."
  280.                ;;
  281.                (round (+ (* int-slope int-index) int-offset))))
  282.       (dotimes (int-index (int-table-length object))
  283.         (%put-byte (ptr-table-data object) (int-index->data-value int-index)
  284.                    int-index))))
  285. |#
  286.   ;; Install a square wave:
  287.   (progn (loop for int-index from 0 to (round (int-table-length object) 2) do
  288.                (%put-byte (ptr-table-data object) #xFF int-index))
  289.          (loop for int-index from (1+ (round (int-table-length object) 2))
  290.                to (1- (int-table-length object)) do
  291.                (%put-byte (ptr-table-data object) #x00 int-index))))
  292.  
  293.  
  294. (defmethod window-null-event-handler ((window sound-dialog))
  295.   "Releases any channels that are in the *quietNotReleased* state."
  296.   ;;
  297.   (when (and (slot-boundp window 'channel1)   ;in case we're not fully
  298.              (slot-boundp window 'channel2)   ; initialized
  299.              (slot-boundp window 'channel3)
  300.              (slot-boundp window 'channel4))
  301.     (release-channel-if-*quietNotReleased* (channel1 window))
  302.     (release-channel-if-*quietNotReleased* (channel2 window))
  303.     (release-channel-if-*quietNotReleased* (channel3 window))
  304.     (release-channel-if-*quietNotReleased* (channel4 window))))
  305.  
  306.  
  307. (defmethod window-close :after ((view sound-dialog))
  308.   "Calls quiet&release-channel, deallocates VIEW's four sound channels, and
  309. deallocates the wave table data."
  310.   ;;
  311.   (quiet&release-channel (channel1 view))
  312.   (quiet&release-channel (channel2 view))
  313.   (quiet&release-channel (channel3 view))
  314.   (quiet&release-channel (channel4 view))
  315.   (dispose-record (channel1 view))
  316.   (dispose-record (channel2 view))
  317.   (dispose-record (channel3 view))
  318.   (dispose-record (channel4 view))
  319.   ;;
  320.   (#_DisposePtr (ptr-table-data view)))
  321.  
  322.  
  323. (defmethod view-key-event-handler ((view sound-dialog)
  324.                                     (char character))
  325.   "Handles the case of characters not handled below by doing nothing."
  326.   ;;
  327.   nil)
  328.  
  329.  
  330. (defmethod view-key-event-handler ((view sound-dialog)
  331.                                     (char (eql #\4)))
  332.   (play-button-snd view 'TOP-LEFT-ITEM))
  333.  
  334.  
  335. (defmethod view-key-event-handler ((view sound-dialog)
  336.                                     (char (eql #\3)))
  337.   (play-button-snd view 'TOP-RIGHT-ITEM))
  338.  
  339.  
  340. (defmethod view-key-event-handler ((view sound-dialog)
  341.                                     (char (eql #\1)))
  342.   (play-button-snd view 'BOTTOM-LEFT-ITEM))
  343.  
  344.  
  345. (defmethod view-key-event-handler ((view sound-dialog)
  346.                                     (char (eql #\2)))
  347.   (play-button-snd view 'BOTTOM-RIGHT-ITEM))
  348.  
  349.  
  350. ;;;
  351.  
  352.  
  353. (defmethod nick-name->channel ((view sound-dialog)
  354.                                (button-nick-name (eql 'BOTTOM-LEFT-ITEM)))
  355.   (channel1 view))
  356.  
  357.  
  358. (defmethod nick-name->channel ((view sound-dialog)
  359.                                (button-nick-name (eql 'BOTTOM-RIGHT-ITEM)))
  360.   (channel2 view))
  361.  
  362.  
  363. (defmethod nick-name->channel ((view sound-dialog)
  364.                                (button-nick-name (eql 'TOP-LEFT-ITEM)))
  365.   (channel3 view))
  366.  
  367.  
  368. (defmethod nick-name->channel ((view sound-dialog)
  369.                                (button-nick-name (eql 'TOP-RIGHT-ITEM)))
  370.   (channel4 view))
  371.  
  372.  
  373. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  374. ;;;
  375. ;;; LISP-level sound commands.
  376. ;;;
  377.  
  378. (defmethod send-sound-command ((p-channel macptr)
  379.                                 (cmd fixnum)
  380.                                 (param1 fixnum)
  381.                                 (param2 fixnum)
  382.                                 &key (immediate? nil))
  383.   "Sends CMD, PARAM1, and PARAM2 to P-CHANNEL via #_SndDoImmediate if
  384. IMMEDIATE? is non-nil, or via #_SndDoCommand."
  385.   ;;
  386.   (rlet ((p-command :SndCommand :cmd cmd :param1 param1 :param2 param2))
  387.     (handle-error
  388.      (if immediate?
  389.        (#_SndDoImmediate p-channel p-command)
  390.        (#_SndDoCommand   p-channel p-command nil)))))
  391.  
  392.  
  393. (defmethod release-channel ((p-channel macptr))
  394.   "Sets P-CHANNEL's userInfo field to *released* and calls
  395. #_SndDisposeChannel on P-CHANNEL."
  396.   ;;
  397.   (rset p-channel SndChannel.userInfo *released*)
  398.   (handle-error (#_SndDisposeChannel p-channel nil)))
  399.  
  400.  
  401. (defmethod flush&quiet-p-channel ((p-channel macptr))
  402.   "Sends #$flushCmd and #$quietCmd to P-CHANNEL."
  403.   ;;
  404.   (send-sound-command p-channel #$flushCmd 0 0 :immediate? t)
  405.   (send-sound-command p-channel #$quietCmd 0 0 :immediate? t))
  406.  
  407.  
  408. (defmethod release-channel-if-*quietNotReleased* ((p-channel macptr))
  409.   "Calls release-channel on P-CHANNEL if its state is *quietNotReleased*."
  410.   ;;
  411.   (let ((state (rref p-channel SndChannel.userInfo)))
  412.     (when (= state *quietNotReleased*)
  413.       (release-channel p-channel))))
  414.  
  415.  
  416. (defmethod quiet&release-channel ((p-channel macptr))
  417.   "Calls flush&quiet-p-channel on P-CHANNEL if it is not in the *released*
  418. state, calls release-channel on it, then sets its userInfo field to
  419. *released*."
  420.   ;;
  421.   (let ((state (rref p-channel SndChannel.userInfo)))
  422.     ;;
  423.     ;; Check that STATE is valid. (This s/b a separate routine.)
  424.     ;;
  425.     (when (and (/= state *playing*)
  426.                (/= state *quietNotReleased*)
  427.                (/= state *released*))
  428.       (error "~S is not one of these known states: ~S."
  429.              state (list *released* *quietNotReleased* *playing*)))
  430.     ;;
  431.     ;; Quiet the channel if necessary.
  432.     ;;
  433.     (when (= state *playing*)
  434.       (flush&quiet-p-channel p-channel))
  435.     ;;
  436.     ;; Release the channel and reset the userInfo flag (to show it's
  437.     ;; *released*) if necessary.
  438.     ;;
  439.     (when (or (= state *playing*)
  440.               (= state *quietNotReleased*))
  441.       (release-channel p-channel))))
  442.  
  443.  
  444. (defmethod play-button-snd ((view sound-dialog)
  445.                             (button-nick-name symbol))
  446.   "Plays the sound corresponding to BUTTON-NICK-NAME by getting the item's
  447. dialog-item-text and using it to play a sounds on one of the syths."
  448.   ;;
  449.   (let* ((snd-id (dialog-item-text (view-named button-nick-name view)))
  450.          ;(h-sound (get-named-resource "snd " snd-id))
  451.          (int-note-value (int-snd-id->note-value snd-id))
  452.          (p-channel (nick-name->channel view button-nick-name)))
  453.     ;(play-snd h-sound p-channel)
  454.     (play-note int-note-value p-channel         ;mc 2-Oct-91
  455.                :square-wave? nil
  456.                :int-table-length (int-table-length view)
  457.                :ptr-table-data (ptr-table-data view)
  458.                :int-amplitude 128)))
  459.  
  460.  
  461. (defmethod int-snd-id->note-value ((snd-id string))      ;mc 2-Oct-91
  462.   "Returns the integer corresponding to snd-id that is the MIDI note value
  463. to play."
  464.   ;;
  465.   (let ((alist-id/note-pairs '(("Got an IV started" . 60)    ;middle c
  466.                                ("Trouble with the IV" . 62)         ;d
  467.                                ("Got The Tube In" . 64)   ;e
  468.                                ("Trouble with the Tube" . 65)        ;f
  469.                                )))
  470.     (or (cdr (assoc snd-id alist-id/note-pairs :test #'string-equal))
  471.         (error "~S not in ~S." snd-id alist-id/note-pairs))))
  472.  
  473.  
  474. (defmethod play-note ((int-note-value fixnum) (p-channel macptr)
  475.                       &key (square-wave? t) int-table-length ptr-table-data
  476.                       (int-amplitude 128))
  477.   "Plays in p-channel the note indicated by int-note-value. First calls
  478. quiet&release-channel in case it's in *quietNotReleased* or *playing*. If
  479. square-wave? is non-nil then uses the #$squareWaveSynth. Otherwise, uses the
  480. #$waveTableSynth and a square wave. Int-table-length and ptr-table-data
  481. specify the wave table. Int-amplitude is an integer between 0 and 255
  482. inclusive."
  483.   ;;
  484.   (quiet&release-channel p-channel)
  485.   ;;
  486.   ;; Since #_SndNewChannel expects a pointer to a pointer we must use a
  487.   ;; %stack-block to store its address.
  488.   ;;
  489.   (%stack-block ((pp-chan 4))
  490.     (%put-ptr pp-chan p-channel)
  491.     (handle-error (#_SndNewChannel pp-chan (if square-wave?
  492.                                              #$squareWaveSynth #$waveTableSynth)
  493.                    #$initMono            ;0 0 breaks here!
  494.                    *snd-call-back-ptr*)))
  495.   ;;
  496.   (rset p-channel SndChannel.userInfo *playing*)         ;set to *quietNotReleased* by *snd-call-back-ptr*
  497.   (unless square-wave?                  ;install the wave table first if necessary
  498.     (send-sound-command p-channel #$waveTableCmd int-table-length
  499.                         (%ptr-to-int ptr-table-data)))
  500.   ;;
  501.   ;; Problem: #$ampCmd does nothing for #$waveTableSynth !!
  502.   ;;
  503.   (send-sound-command p-channel #$ampCmd int-amplitude 0)
  504.   ;(%stack-block ((p-int-volume 4))    ;note: s/b doing something like this!
  505.   ;  (#_GetSoundVol p-int-volume)
  506.   ;  (%get-word p-int-volume))
  507.   ;
  508.   ;(#_SetSoundVol (round (* int-amplitude 7) 255))       ;slows it down a bit
  509.   (send-sound-command p-channel #$freqDurationCmd
  510.                       500 int-note-value)       ;500 = 1/4 sec
  511.   ;(send-sound-command p-channel #$quietCmd 0 0)          ;required for #$freqDurationCmd
  512.   (send-sound-command p-channel #$callBackCmd 0 0))
  513.  
  514.  
  515. (defmethod play-snd ((h-sound macptr)   ;there is no machandle class, right?
  516.                      (p-channel macptr))
  517.   "Plays in P-CHANNEL the sound pointed to by H-SOUND. First calls
  518. quiet&release-channel in case it's in *quietNotReleased* or *playing*."
  519.   ;;
  520.   (quiet&release-channel p-channel)
  521.   ;;
  522.   ;; Since #_SndNewChannel expects a pointer to a pointer we must use a
  523.   ;; %stack-block to store its address.
  524.   ;;
  525.   (%stack-block ((pp-chan 4))
  526.     (%put-ptr pp-chan p-channel)
  527.     (handle-error (#_SndNewChannel pp-chan #$sampledSynth #$initMono ;0 0 breaks here!
  528.                    *snd-call-back-ptr*)))
  529.   ;;
  530.   (rset p-channel SndChannel.userInfo *playing*)   ;set to *quietNotReleased* by *snd-call-back-ptr*
  531.   (handle-error (#_SndPlay p-channel h-sound t))  ;async!
  532.   (send-sound-command p-channel #$callBackCmd 0 0))
  533.  
  534.  
  535. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  536. ;;;
  537. ;;; Define functions to print nice SoundManager error messages.
  538. ;;;
  539.  
  540. (defclass error-entry ()
  541.   ((error-name
  542.     :accessor error-name
  543.     :initarg :error-name
  544.     :type string)
  545.    (error-number
  546.     :accessor error-number
  547.     :initarg :error-number
  548.     :type fixnum)
  549.    (error-description
  550.     :accessor error-description
  551.     :initarg :error-description
  552.     :type string)
  553.    )
  554.   (:documentation "Stores error information as imported from the InsideMac
  555. stacks."))
  556.  
  557.  
  558. (defmethod print-object ((object error-entry) stream)
  559.   "Prints OBJECT with its components."
  560.   ;;
  561.   (print-unreadable-object (object stream :type t :identity t)
  562.     (cond ((and (slot-boundp object 'error-name)
  563.                 (slot-boundp object 'error-number))
  564.            (format stream "~A ~A" (error-name object) (error-number object)))
  565.           (t
  566.            (princ "??" stream)))))
  567.  
  568.  
  569. (defmethod parse-hypercard-error-list ((error-list string))
  570.   "Returns as list of error-entries sorted in descending error-number
  571. order. ERROR-LIST is a string of lines; each line is of the form:
  572.   '<error-name> <error-number> <error-description>
  573.  
  574. and each item is separated by spaces."
  575.   ;;
  576.   (with-input-from-string (stream (substitute #\- #\– error-list))
  577.     (let ((num-lines (count #\Return error-list))
  578.           (error-list ())  ;form: list of (name value descr)
  579.           line error-name-start error-name-end error-name
  580.           error-number-start error-number-end error-number
  581.           error-descr-start error-descr-end error-descr)
  582.       (dotimes (line-num num-lines)
  583.         (setf line (read-line stream)
  584.               error-name-start 0
  585.               error-name-end (position #\Space line :start error-name-start)
  586.               error-name (subseq line error-name-start error-name-end)
  587.               error-number-start
  588.               (position-if-not #'(lambda (char) (char-equal char #\Space))
  589.                                line :start error-name-end)
  590.               error-number-end (position #\Space line :start error-number-start)
  591.               error-number (read-from-string (subseq line error-number-start error-number-end))
  592.               error-descr-start
  593.               (position-if-not #'(lambda (char) (char-equal char #\Space))
  594.                                line :start error-number-end)
  595.               error-descr-end (length line)
  596.               error-descr (subseq line error-descr-start error-descr-end))
  597.         (push (make-instance
  598.                'error-entry :error-name error-name
  599.                :error-number error-number
  600.                :error-description error-descr)
  601.               error-list))
  602.       error-list)))
  603.  
  604.  
  605. (defvar *sound-manager-errors*
  606.   (parse-hypercard-error-list
  607. "noErr                                            0       No error
  608. noHardwareErr                   –200       Required sound hardware not available
  609. notEnoughHardwareErr   –201      Insufficient hardware available
  610. queueFull                             –203      No room in the queue
  611. resProblem                           –204      Problem loading the resource
  612. badChannel                         –205       Channel is corrupt or unusable
  613. badFormat                            –206      Resource is corrupt or unusable
  614. notEnoughBufferSpace     –207      Insufficient memory available
  615. badFileFormat                     –208      File is corrupt or unusable, or not AIFF or AIFF-C
  616. channelBusy                        –209      Channel is busy
  617. buffersTooSmall                 –210      Buffer is too small
  618. channelNotBusy                 –211      Channel not currently used
  619. noMoreRealTime               –212      Not enough CPU time available
  620. siNoSoundInHardware    –220       No sound input hardware available
  621. siBadSoundInDevice         –221       Invalid sound input device
  622. siNoBufferSpecified          –222       No buffer specified
  623. siInvalidCompression      –223       Invalid compression type
  624. siHardDriveTooSlow        –224       Hard drive too slow to record
  625. siInvalidSampleRate         –225       Invalid sample rate
  626. siInvalidSampleSize          –226      Invalid sample size
  627. siDeviceBusyErr                  –227      Sound input device is busy
  628. siBadDeviceName             –228       Invalid device name
  629. siBadRefNum                     –229       Invalid reference number
  630. siInputDeviceErr                –230       Input device hardware failure
  631. siUnknownInfoType         –231      Unknown type of information
  632. siUnknownQuality            –232      Unknown quality")
  633.   "A list of error-entries sorted as returned by
  634. parse-hypercard-error-list.")
  635.  
  636.  
  637. (defmethod error-code->error-entry ((error-code fixnum))
  638.   "Returns the error-entry in *sound-manager-errors* corresponding to
  639. ERROR-CODE or nil if none found."
  640.   ;;
  641.   (find error-code *sound-manager-errors* :test #'= :key #'error-number))
  642.  
  643.  
  644. (defmethod handle-error ((error-code fixnum))
  645.   "The top-level function for handling Sound Manager errors."
  646.   ;;
  647.   (unless (zerop error-code)
  648.     (let ((error-entry (error-code->error-entry error-code)))
  649.       (error "Sound Manager error (~S): ~A." error-code
  650.              (if error-entry (error-description error-entry) "Unknown")))))
  651.  
  652.  
  653. #|
  654.  
  655. (make-instance 'sound-dialog)
  656.  
  657. |#
  658.